Mac Magazin/MacEasy 14/Mac Magazin and MacEasy Magazine CD - Issue 14.iso/Utilities/Grabbug1.0b2 Folder/Source/GrabbugCommon.p

Text File | 1995-08-24 | 11.8 KB | 402 lines | [TEXT/MWPS]

unit GrabbugCommon;

(* ©1995 Quinn "The Eskimo!" *)
(* This file is distributed as Freeware. *)

interface

    uses
        Types;

    const
        noDcmdErr = -6660;
        screenSizeChangedErr = -6661;
        noMainGDeviceErr = -6662;
        noGrabErr = -6663;
        screenSizeChangedErr2 = -6664;

    const
        gestaltGrabbugVariables = 'Gräb';
        grabbug_creator = 'Gräb';

    (* The following routines are used by the dcmd. *)

    function DoInit(var refcon : longint) : OSErr;
    function DoGrab(refcon : longint) : OSErr;
    procedure DoTerm(refcon : longint);

    (* The following routine is used by Grabbug Dump. *)

    function DoDump : OSErr;

implementation

    uses
        Files,
        Memory,
        QuickDraw,
        QDOffscreen,
        TextUtils,
        LowMem,
        GestaltEqu;

(* ***** Utilities copied out of my libraries ***** *)

    procedure UniqueFileName(prefix : Str255; var fss : FSSpec);
        var
            err : OSErr;
            attempt : integer;
            filename : Str255;
    begin
        attempt := 0;
        repeat
            NumToString(attempt, filename);
            filename := concat(prefix, filename);
            err := FSMakeFSSpec(-1, 2, filename, fss);
            attempt := attempt + 1;
        until (err = fnfErr) or (attempt > 1000);
    end; (* UniqueFileName *)

    function FSWriteQ(refnum : integer; count : longint; buf : univ Ptr) : OSErr;
    begin
        FSWriteQ := FSWrite(refnum, count, buf);
    end; (* FSWriteQ *)

    procedure BlockClear(dest : univ Ptr; size : longint);
        type
            memBlock = packed array [0..16000000] of byte;
            memBlockPtr = ^memBlock;
        var
            i : longint;
            tmpdest : memBlockPtr;
    begin
        tmpdest := memBlockPtr(dest);
        for i := 0 to size - 1 do begin
            tmpdest^[i] := 0;
        end; (* for *)
    end; (* BlockClear *)

(* **** Common bits **** *)

    function GetMainScreenInfo(var pm_base : Ptr; var pm_32bit : boolean; var pm_rowbytes : integer; var pm_size : longint) : OSErr;
        (* Gets various attributes about the main display.  This routine peers inside
            structures rather than using the defined API because I anticipate that
                it will be called at all sorts of odd times.
        *)
        var
            err : OSErr;
            main_gd : GDHandle;
            gdpm : PixMapHandle;
    begin
        err := noErr;
        main_gd := LMGetMainDevice;
        if main_gd = nil then begin
            err := noMainGDeviceErr;
        end; (* if *)
        if err = noErr then begin
            gdpm := main_gd^^.gdPMap;
            pm_32bit := PixMap32Bit(gdpm);    (* some disassembly reveals that it's reasonably safe to call this (: *)
            pm_base := gdpm^^.baseAddr;
            pm_rowbytes := band(gdpm^^.rowBytes, $3FFF);
            pm_size := longint(pm_rowbytes) * (gdpm^^.bounds.bottom - gdpm^^.bounds.top);
        end; (* if *)
        GetMainScreenInfo := err;
    end; (* GetMainScreenInfo *)

    (* The globals record pointed to by the Gestalt selector. *)

    type
        myGlobals = record
            signature : OSType;
            version : integer;
            have_grabbed : boolean;
            screen_rowbytes : integer;
            screen_buffer : Ptr;
            screen_buffer_size : longint;
        end;
        myGlobalsPtr = ^myGlobals;

(* **** These bits slated for the application ***** *)

    function CreateOpenPictureFile(fss : FSSpec; var ref : integer) : OSErr;
        (* Create a picture file, open it and write out the 512 bytes of zeros
                which make up the header.
        *)
        var
            err : OSErr;
            header : packed array [0..511] of byte;
    begin
        ref := 0;
        err := FSpCreate(fss, 'ttxt', 'PICT', 0);
        if err = noErr then begin
            err := FSpOpenDF(fss, fsRdWrPerm, ref);
        end; (* if *)
        if err = noErr then begin
            BlockClear(@header, sizeof(header));
            err := FSWriteQ(ref, sizeof(header), @header);
        end; (* if *)
        CreateOpenPictureFile := err;
    end; (* CreateOpenPictureFile *)

    (* ----- The PutPic Engine ----- *)

    (* The PutPic engine is a replacement for QuickDraw's StdPutPic proc that
            spools the file into a PICT file instead of into the picture. There
            are initialisation and termination procedures that setup and shutdown
            the engine, and a replacement for the QuickDraw bottleneck.
    *)

    (* Some state variables for the PutPic engine. *)

    var
        myputpic_err : OSErr;                        (* a sticky error code *)
        myputpic_ref : integer;                    (* dest file refnum *)

    procedure MyPutPic(data : Ptr; size : integer);
        (* A replacement for QuickDraw's StdPutPic. *)
    begin
        if myputpic_err = noErr then begin
            myputpic_err := FSWriteQ(myputpic_ref, size, data);
        end; (* if *)
    end; (* MyPutPic *)

    procedure InitMyPutPic(var mycqdprocs : CQDProcs; ref : integer);
        (* Initialise the PutPic engine. *)
    begin
        SetStdCProcs(mycqdprocs);
        mycqdprocs.putPicProc := @MyPutPic;
        CGrafPtr(qd.thePort)^.grafProcs := @mycqdprocs;
        myputpic_err := noErr;
        myputpic_ref := ref;
    end; (* InitMyPutPic *)

    function TermMyPutPic(picth : PicHandle; ref : integer) : OSErr;
        (* Shut down the PutPic engine, most importantly
            write the final picture header into the right place in the file.
        *)
    begin
        if GetHandleSize(Handle(picth)) <> 10 then begin
            DebugStr('Fatal assumption failure.');
        end; (* if *)
        (* write the final picture header into the right place in the file *)
        if myputpic_err = noErr then begin
            myputpic_err := SetFPos(ref, fsFromStart, 512);
        end; (* if *)
        MyPutPic(Ptr(picth^), 10);
        TermMyPutPic := myputpic_err;
    end; (* TermMyPutPic *)

    function DoDump : OSErr;
        (* Dump the captured screen to a new PICT file on the disk. *)

        function SpoolPicture(dcmd_globals : myGlobalsPtr; ref : integer) : OSErr;
            (* Creates an offscreen GWorld and copies the captured screen data into
                    it, having set up to spool the resulting PICT to a file.
               This routine is pretty slack about cleaning up, simply because we expect to
                    clean up at application termination time.
            *)
            var
                err : OSErr;
                gworld : GWorldPtr;
                screen_rect : Rect;
                picth : PicHandle;
                src_pixmap : PixMapHandle;
                junk_bool : boolean;
                mycqdprocs : CQDProcs;
        begin
            (* create an offscreen GWorld *)
            (* and make a pixmap out of the screen_buffer *)
            err := noErr;
            if err = noErr then begin
                err := NewGWorld(gworld, 0, GetMainDevice^^.gdPMap^^.bounds, nil, nil, noNewDevice);
            end; (* if *)
            if err = noErr then begin
                SetGWorld(gworld, nil);
                junk_bool := LockPixels(GetGWorldPixMap(gworld));
                src_pixmap := NewPixMap;
                if src_pixmap = nil then begin
                    err := memFullErr;
                end; (* if *)
            end; (* if *)
            if err = noErr then begin
                CopyPixMap(GetMainDevice^^.gdPMap, src_pixmap);                (* gets the colour table correct *)
                HLock(Handle(src_pixmap));
                src_pixmap^^.baseAddr := dcmd_globals^.screen_buffer;    (* point it at the dcmd's buffer *)
                screen_rect := GrafPtr(gworld)^.portRect;
                (* setup PutPic procedure *)
                InitMyPutPic(mycqdprocs, ref);                                                (* prepare for spooling *)
                (* spool the bitmap into a picture *)
                picth := OpenPicture(screen_rect);
                MyPutPic(Ptr(picth^), 10);                                                        (* write the bogus header *)
                ClipRect(GrafPtr(gworld)^.portRect);
                CopyBits(BitMapPtr(src_pixmap^)^, GrafPtr(gworld)^.portBits, screen_rect, screen_rect, srcCopy, nil);
                err := QDError;
                ClosePicture;
            end; (* if *)
            if err = noErr then begin
                err := TermMyPutPic(picth, ref);                                            (* shut down spool *)
            end; (* if *)
            SpoolPicture := err;
        end; (* SpoolPicture *)

        var
            err : OSErr;
            err2 : OSErr;
            dcmd_globals : myGlobalsPtr;
            fss : FSSpec;
            ref : integer;
            junk_bool : boolean;
            junk_ptr : Ptr;
            pm_rowbytes : integer;
            pm_size : longint;
    begin
        (* look up dcmd's globals *)
        err := Gestalt(gestaltGrabbugVariables, longint(dcmd_globals));
        if err = gestaltUndefSelectorErr then begin
            err := noDcmdErr;
        end; (* if *)
        (* check that the dcmd's state is compatible *)
        if err = noErr then begin
            if not dcmd_globals^.have_grabbed then begin
                err := noGrabErr;
            end; (* if *)
        end; (* if *)
        if err = noErr then begin
            err := GetMainScreenInfo(junk_ptr, junk_bool, pm_rowbytes, pm_size);
            if (err = noErr) and
                        ((pm_rowbytes <> dcmd_globals^.screen_rowbytes) or
                         (pm_size <> dcmd_globals^.screen_buffer_size)) then begin
                err := screenSizeChangedErr2
            end; (* if *)
        end; (* if *)
        (* create and open the PICT file *)
        if err = noErr then begin
            UniqueFileName('Grabbug ', fss);
            err := CreateOpenPictureFile(fss, ref);
        end; (* if *)
        if err = noErr then begin
            err := SpoolPicture(dcmd_globals, ref);
        end; (* if *)
        (* clean up *)
        if ref <> 0 then begin
            err2 := FSClose(ref);
            if err = noErr then begin
                err := err2;
            end; (* if *)
        end; (* if *)
        DoDump := err;
    end; (* DoDump *)

(* **** These bits slated for the dcmd **** *)

(* These headers for copied out of GestaltEqu.p otherwise I would have
        had to engage System 7.5 or later, which would have required me
        to recompile CW's pre-compiled header, which I didn't have the disk
        space to do!
*)

{ These functions are built into System 7.5, but not on earlier systems }
FUNCTION NewGestaltValue(selector: OSType; newValue: LONGINT): OSErr;
    {$IFC NOT GENERATINGCFM}
    INLINE $303C, $0401, $ABF1;
    {$ENDC}
FUNCTION ReplaceGestaltValue(selector: OSType; replacementValue: LONGINT): OSErr;
    {$IFC NOT GENERATINGCFM}
    INLINE $303C, $0402, $ABF1;
    {$ENDC}
FUNCTION SetGestaltValue(selector: OSType; newValue: LONGINT): OSErr;
    {$IFC NOT GENERATINGCFM}
    INLINE $303C, $0404, $ABF1;
    {$ENDC}
FUNCTION DeleteGestaltValue(selector: OSType): OSErr;
    {$IFC NOT GENERATINGCFM}
    INLINE $303C, $0203, $ABF1;
    {$ENDC}

    function DoInit(var refcon : longint) : OSErr;
        (* Initialises the dcmd, first creating and registering its globals
                and then creating the screen capture buffer.
        *)
        var
            err : OSErr;
            my_globals : myGlobalsPtr;
            pm_base : Ptr;
            pm_32bit : boolean;
    begin
        err := noErr;
        (* create and initialise the globals and register them with Gestalt *)
        my_globals := myGlobalsPtr(NewPtrSys(sizeof(myGlobals)));
        refcon := longint(my_globals);
        if my_globals = nil then begin
            err := memFullErr;
        end; (* if *)
        if err = noErr then begin
            my_globals^.signature := gestaltGrabbugVariables;
            my_globals^.version := 0;
            my_globals^.have_grabbed := false;
            my_globals^.screen_rowbytes := 0;
            my_globals^.screen_buffer := nil;
            my_globals^.screen_buffer_size := 0;
            err := NewGestaltValue(gestaltGrabbugVariables, longint(my_globals))
        end; (* if *)
        (* create the screen capture buffer *)
        if err = noErr then begin
            err := GetMainScreenInfo(pm_base, pm_32bit, my_globals^.screen_rowbytes, my_globals^.screen_buffer_size);
            if err = noErr then begin
                my_globals^.screen_buffer := NewPtrSys(my_globals^.screen_buffer_size);
                err := MemError;
            end; (* if *)
        end; (* if *)
        DoInit := err;
    end; (* DoInit *)

    function DoGrab(refcon : longint) : OSErr;
        (* Capture the screen by copying it to the screen buffer. *)
        var
            my_globals : myGlobalsPtr;
            err : OSErr;
            mmu_mode : SInt8;
            pm_base : Ptr;
            pm_32bit : boolean;
            pm_rowbytes : integer;
            pm_size : longint;
    begin
        my_globals := myGlobalsPtr(refcon);
        err := GetMainScreenInfo(pm_base, pm_32bit, pm_rowbytes, pm_size);
        if err = noErr then begin
            if (pm_size <> my_globals^.screen_buffer_size)
                    or (pm_rowbytes <> my_globals^.screen_rowbytes) then begin
                err := screenSizeChangedErr;
            end; (* if *)
        end; (* if *)
        if err = noErr then begin
            if pm_32bit then begin
                mmu_mode := true32b;
                SwapMMUMode(mmu_mode);
            end; (* if *)
            BlockMove(pm_base, my_globals^.screen_buffer, my_globals^.screen_buffer_size);
            if pm_32bit then begin
                SwapMMUMode(mmu_mode);
            end; (* if *)
            my_globals^.have_grabbed := true;
        end; (* if *)
        DoGrab := err;
    end; (* DoGrab *)

    procedure DoTerm(refcon : longint);
        (* Terminate the dcmd, clean up the globals. *)
        var
            junk : OSErr;
            my_globals : myGlobalsPtr;
    begin
        my_globals := myGlobalsPtr(refcon);
        junk := DeleteGestaltValue(gestaltGrabbugVariables);
        if (my_globals <> nil) & (my_globals^.screen_buffer <> nil) then begin
            DisposePtr(my_globals^.screen_buffer);
        end; (* if *)
        if my_globals <> nil then begin
            DisposePtr(Ptr(my_globals));
        end; (* if *)
    end; (* DoTerm *)

end. (* GrabbugCommon *)